home *** CD-ROM | disk | FTP | other *** search
/ Celestin Apprentice 4 / Apprentice-Release4.iso / Languages / Caml Light 0.7 / examples / asl / parser.ml < prev    next >
Encoding:
Text File  |  1995-06-01  |  1.7 KB  |  66 lines  |  [TEXT/MPS ]
  1. (* $Id: parser.ml,v 1.3 1994/11/10 09:57:22 xleroy Exp $ *)
  2.  
  3. #open "asl";;
  4. #open "stream";;
  5. #open "token";;
  6.  
  7. exception Unbound of string;;
  8.  
  9. let binding_depth s rho = 
  10.   try Var(index s rho + 1)
  11.   with Not_found -> raise (Unbound s);;
  12. let init_env =  ["+";"-";"*";"/";"="];;
  13. let global_env = ref init_env;;
  14.  
  15. let rec list p = function
  16.   [< p x; (list p) l >] -> x::l
  17. | [< >] -> []
  18. ;;
  19.  
  20. let option p = function
  21.   [< p x >] -> Some x
  22. | [< >] -> None
  23. ;;
  24.  
  25. (* parsing *)
  26.  
  27. let rec expr = function
  28.   [< 'BSLASH ; 'IDENT s ; 'DOT ; expr e >] ->
  29.     (function rho -> Abs(s, e(s::rho)))
  30. | [< expr0 e ; (list expr0) l >] ->
  31.     it_list (fun e1 e2 rho -> App(e1 rho, e2 rho)) e l
  32.  
  33. and expr0 = function
  34.   [< 'INT n >] -> (function _ -> Const n)
  35. | [< 'IDENT s >] -> binding_depth s
  36. | [< 'OP s >] -> binding_depth s
  37. | [< 'EQUAL >] -> binding_depth "="
  38. | [< 'IF ; expr e1 ; 'THEN ; expr e2 ; 'ELSE ; expr e3 ; 'FI >] ->
  39.     (function rho -> Cond(e1 rho, e2 rho, e3 rho))
  40. | [< 'LPAREN ; (option expr) e ; 'RPAREN >] ->
  41.     (match e with Some e -> e | _ -> (fun _-> Const(-1)))
  42. ;;
  43.  
  44. let top = function
  45.   [< 'LET ; 'IDENT s ; 'EQUAL ; expr e ; 'SEMICOL >] -> Decl(s, e !global_env)
  46. | [< expr e ; 'SEMICOL >] -> Decl("it", e !global_env)
  47. | [< '_ >] -> raise Parse_error
  48. ;;
  49.  
  50. (* impression de l'arbre *)
  51.  
  52. let rec print_expr = function
  53.   Abs(s, a) -> [< '"Abs (\""; 's; '"\", "; print_expr a; '")" >]
  54. | App(e1, e2) -> [< '"App ("; print_expr e1; '", "; print_expr e2; '")" >]
  55. | Const c -> [< '"Const "; 'string_of_int c >]
  56. | Var v -> [< '"Var "; 'string_of_int v >]
  57. | Cond(e1, e2, e3) -> [<
  58.     '"Cond ("; print_expr e1; '", "; print_expr e2; '", ";
  59.     print_expr e3; '")"
  60.   >]
  61. ;;
  62.  
  63. let print_top = function
  64.   Decl(s,a) -> [< '"Decl (\""; 's; '"\", "; print_expr a; '")" >]
  65. ;;
  66.